home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-04
/
aie9009.zip
/
FRAMES.ZIP
/
ES2M.ARI
< prev
next >
Wrap
Text File
|
1990-07-09
|
17KB
|
473 lines
% FRAME-BASED EXPERT SYSTEM
%
% by
%
% Instant Recall
% P.O. Box 30134
% Bethesda, Md. 20814
% (301) 530-0898
% BBS: (301) 530-2890
%
% (C) Copyright 1990 by Instant Recall
% All Rights Reserved
:- module es2m.
:- public main_hlpr / 0 : far .
:- extrn get_kb /0 : far .
:- extrn trace_message/ 3 : far .
:- extrn log_listing / 1 : far .
:- extrn init_log_file / 0 : interp .
:- extrn rule / 1 : interp .
:- extrn goal / 1 : interp .
:- extrn close_log_file / 0 : interp .
:- extrn retractall / 1 : far .
:- extrn log_put / 1 : far .
:- extrn log_write/ 1 : far .
:- extrn log_nl / 0 : far .
:- extrn frame_op / 2 : far .
:- extrn frame_op / 3 : far .
:- extrn frame_op / 4 : far .
:- extrn frame_op / 5 : far .
:- extrn frame_op / 6 : far .
:- extrn test / 0 : far .
%%%%%%%% op defs %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- op( 450 , yfx , or ).
:- op( 440 , yfx , and ).
main_hlpr :-
reconsult($traceflg.con$),
reconsult($newtrace.pro$),
call( init_log_file),
% test,
/*-TRACE-*/ trace_message( main_hlpr / 0 ,
/*-TRACE-*/ $b get_data$,
/*-TRACE-*/ $$ ),
get_kb ,
/*-TRACE-*/ trace_message( main_hlpr / 0 ,
/*-TRACE-*/ $b solve$,
/*-TRACE-*/ $$ ),
setup ,
solve ,
log_listing( statement / 1 ) ,
call( close_log_file),
halt.
solve :-
/*-TRACE-*/ trace_message( solve / 0 ,
/*-TRACE-*/ $e$,
/*-TRACE-*/ $$ ),
find_goal( GOAL ),
/*-TRACE-*/ trace_message( solve / 0 ,
/*-TRACE-*/ $...GOAL = $,
/*-TRACE-*/ GOAL ),
try( GOAL ).
find_goal( GOAL ) :-
frame_op( $retrieve frame from database$,
statement( [ goal : true ] ),
GOAL ) .
%%%%%%%%%%%%%%% TRYING A GOAL %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% try clause 0 : trace
try( QUESTION ) :-
/*-TRACE-*/ trace_message( try / 1 ,
/*-TRACE-*/ $e, QUESTION = $,
/*-TRACE-*/ QUESTION ),
fail.
% try clause 1 : true is true
try( true ) :- !.
% try clause 2 : Use known results
try( STATEMENT ) :-
is_ground_statement( STATEMENT ) ,
/*-TRACE-*/ trace_message( try / 1 ,
/*-TRACE-*/ $...is_ground_statement succeeds $,
/*-TRACE-*/ $$ ),
frame_op( $get slot values$,
STATEMENT ,
[ description : QUESTION ] ) ,
/*-TRACE-*/ trace_message( try / 1 ,
/*-TRACE-*/ $...QUESTION = $,
/*-TRACE-*/ QUESTION ),
frame_op( $get slot value with default$,
STATEMENT ,
value ,
ANSWER ,
ANSWER ),
/*-TRACE-*/ trace_message( try / 1 ,
/*-TRACE-*/ $...ANSWER = $,
/*-TRACE-*/ ANSWER ),
find_statement( QUESTION , STATEMENT_OBJECT ),
/*-TRACE-*/ trace_message( try / 1 ,
/*-TRACE-*/ $...STATEMENT_OBJECT = $,
/*-TRACE-*/ STATEMENT_OBJECT ),
frame_op( $get slot value$,
STATEMENT_OBJECT,
value ,
ANSWER1 ),
/*-TRACE-*/ trace_message( try / 1 ,
/*-TRACE-*/ $...ANSWER1 = $,
/*-TRACE-*/ ANSWER1 ),
( ANSWER = ANSWER1,
!
; !,
fail
)
/*-TRACE-*/ ,trace_message( try / 1 ,
/*-TRACE-*/ $x, succeeds : $,
/*-TRACE-*/ STATEMENT )
.
% try clause 3 : don't try again goals that could not be solved
try( STATEMENT ) :-
is_ground_statement( STATEMENT ) ,
frame_op( $get slot value$,
STATEMENT,
description ,
QUESTION ),
find_statement( QUESTION , STATEMENT_OBJECT ),
frame_op( $get slot value$,
STATEMENT_OBJECT ,
already_tried,
true ),
/*-TRACE-*/ trace_message( try / 1 ,
/*-TRACE-*/ $...FAILS , already tried : $,
/*-TRACE-*/ STATEMENT ),
!,
fail.
% try clause 4 : ask user
try( STATEMENT ) :-
/*-TRACE-*/ trace_message( try / 1 ,
/*-TRACE-*/ $e, ask rule = $,
/*-TRACE-*/ $$ ),
is_ground_statement( STATEMENT ) ,
/*-TRACE-*/ trace_message( try / 1 ,
/*-TRACE-*/ $...b frame_op$,
/*-TRACE-*/ $$ ),
frame_op( $get slot values$,
STATEMENT,
[ description : QUESTION ,
value : ANSWER ] ) ,
/*-TRACE-*/ trace_message( try / 1 ,
/*-TRACE-*/ $...b find_statement$,
/*-TRACE-*/ $$ ),
find_statement( QUESTION , STATEMENT_OBJECT ),
/*-TRACE-*/ trace_message( try / 1 ,
/*-TRACE-*/ $...b frame_op$,
/*-TRACE-*/ $$ ),
frame_op( $get slot values$,
STATEMENT_OBJECT ,
[ dont_ask : optional : false ,
user_doesnt_know : optional : false ] ,
[ dont_ask : false ,
user_doesnt_know : false ] ) ,
/*-TRACE-*/ trace_message( try / 1 ,
/*-TRACE-*/ $....b ask$,
/*-TRACE-*/ $$ ),
ask( STATEMENT_OBJECT, NEW_STATEMENT_OBJECT ),
/*-TRACE-*/ trace_message( try / 1 ,
/*-TRACE-*/ $...NEW_STATEMENT_OBJECT = $,
/*-TRACE-*/ NEW_STATEMENT_OBJECT ),
frame_op( $get slot value$,
NEW_STATEMENT_OBJECT,
value ,
ANSWER1 ),
( ANSWER = ANSWER1,
!
; !,
fail
)
/*-TRACE-*/ ,trace_message( try / 1 ,
/*-TRACE-*/ $x, succeeds : $,
/*-TRACE-*/ STATEMENT )
.
% try clause 5 : and rule for inference
try( HYPOTHESIS_1 and HYPOTHESIS_2 ) :-
/*-TRACE-*/ trace_message( try / 1 ,
/*-TRACE-*/ $...and rule$,
/*-TRACE-*/ $$ ),
!,
try( HYPOTHESIS_1 ),
try( HYPOTHESIS_2 ).
% try clause 6 : or rule for inference
try( HYPOTHESIS_1 or HYPOTHESIS_2 ) :-
/*-TRACE-*/ trace_message( try / 1 ,
/*-TRACE-*/ $...or rule$,
/*-TRACE-*/ $$ ),
!,
( try( HYPOTHESIS_1 ),
!
;
try( HYPOTHESIS_2 ) ) .
% try clause 7 : ground clause rule for inference
try( CONCLUSION ) :-
is_ground_statement( CONCLUSION ) ,
frame_op( $get slot value$,
CONCLUSION,
description ,
QUESTION ),
/*-TRACE-*/ trace_message( try / 1 ,
/*-TRACE-*/ $...ground statement recursive rule$,
/*-TRACE-*/ $$ ),
% get hypothesis and conclusion
find_rule( CONCLUSION , RULE ),
/*-TRACE-*/ trace_message( try / 1 ,
/*-TRACE-*/ $...RULE = $,
/*-TRACE-*/ RULE ),
frame_op( $get slot values$,
RULE ,
[ hypothesis : HYPOTHESIS,
conclusion : RULE_CONCLUSION ] ),
/*-TRACE-*/ trace_message( try / 1 ,
/*-TRACE-*/ $...HYPOTHESIS = $,
/*-TRACE-*/ HYPOTHESIS ),
find_statement( QUESTION ,
STATEMENT_OBJECT0 ),
/*-TRACE-*/ trace_message( try / 1 ,
/*-TRACE-*/ $...STATEMENT_OBJECT0 = $,
/*-TRACE-*/ STATEMENT_OBJECT0 ),
frame_op( $learn indexed frame update$,
QUESTION ,
STATEMENT_OBJECT0 ,
[ already_tried : true ] ,
STATEMENT_OBJECT ),
/*-TRACE-*/ trace_message( try / 1 ,
/*-TRACE-*/ $... STATEMENT_OBJECT = $,
/*-TRACE-*/ STATEMENT_OBJECT ),
try( HYPOTHESIS ),
/*-TRACE-*/ trace_message( try / 1 ,
/*-TRACE-*/ $...a try$,
/*-TRACE-*/ $$ ),
frame_op( $get slot value$,
RULE_CONCLUSION ,
value ,
RULE_CONCLUSION_VALUE ),
/*-TRACE-*/ trace_message( try / 1 ,
/*-TRACE-*/ $... RULE_CONCLUSION_VALUE = $,
/*-TRACE-*/ RULE_CONCLUSION_VALUE ),
frame_op( $learn indexed and Prolog database frame update$,
QUESTION ,
statement( [ description : QUESTION ] ) ,
STATEMENT_OBJECT ,
[ value : RULE_CONCLUSION_VALUE ],
NEW_STATEMENT_OBJECT ),
/*-TRACE-*/ trace_message( try / 1 ,
/*-TRACE-*/ $... NEW_STATEMENT_OBJECT = $,
/*-TRACE-*/ NEW_STATEMENT_OBJECT ),
report( NEW_STATEMENT_OBJECT ) ,
frame_op( $get slot value with default$,
CONCLUSION ,
value ,
DESIRED_ANSWER ,
DESIRED_ANSWER ),
/*-TRACE-*/ trace_message( try / 1 ,
/*-TRACE-*/ $... DESIRED_ANSWER = $,
/*-TRACE-*/ DESIRED_ANSWER ),
( DESIRED_ANSWER = RULE_CONCLUSION_VALUE,
!
; !,
fail
)
/*-TRACE-*/ ,trace_message( try / 1 ,
/*-TRACE-*/ $X$,
/*-TRACE-*/ $$ )
.
%%%%%%%%%%%%% utility predicates %%%%%%%%%%%%%%%%%%%%%%%%%%%%5
is_yes_no_question( STATEMENT ) :-
frame_op( $get slot value with default$,
STATEMENT ,
value_type,
boolean,
boolean ) .
% asks a question of user
% QUESTION = what to ask
% ANSWER = desired answer
% HOW_LEARNED output variable = user when predicate succeeds
% success when user answer is ANSWER
% fails otherwise.
% if user doesn't know, this is learned
ask( STATEMENT_OBJECT, NEW_STATEMENT_OBJECT ) :-
/*-TRACE-*/ trace_message( ask / 2 ,
/*-TRACE-*/ $e$,
/*-TRACE-*/ $$ ),
is_yes_no_question( STATEMENT_OBJECT ) ,
frame_op( $get slot value$,
STATEMENT_OBJECT,
description,
QUESTION ),
/*-TRACE-*/ trace_message( ask / 2 ,
/*-TRACE-*/ $..b yes_no_ask$,
/*-TRACE-*/ $$ ),
yes_no_ask( QUESTION , ANSWER1 ),
!,
( not ANSWER1 == dont_know,
!,
frame_op( $learn indexed and Prolog database frame update$,
QUESTION ,
statement( [ description : QUESTION ] ) ,
STATEMENT_OBJECT ,
[ value : ANSWER1 ],
NEW_STATEMENT_OBJECT )
;
ANSWER1 = dont_know,
!,
frame_op( $learn indexed and Prolog database frame update$,
QUESTION ,
statement( [ description : QUESTION ] ) ,
STATEMENT_OBJECT ,
[ user_doesnt_know : true ],
NEW_STATEMENT_OBJECT ) ,
fail
).
setup :-
setup_rules ,
setup_statements
/*-TRACE-*/ ,trace_message( setup / 0 ,
/*-TRACE-*/ $x$,
/*-TRACE-*/ $$ )
.
setup_rules :-
/*-TRACE-*/ trace_message( setup_rules / 0 ,
/*-TRACE-*/ $e$,
/*-TRACE-*/ $$ ),
TERM = rule( RULE ) ,
call( TERM ),
frame_op( $get slot value$,
RULE ,
conclusion,
CONCLUSION ),
frame_op( $get slot value$,
CONCLUSION,
description,
DESCRIPTION ),
frame_op( $index frame into database$,
DESCRIPTION ,
TERM ) ,
fail.
setup_rules :- !.
setup_statements :-
/*-TRACE-*/ trace_message( setup_statements / 0 ,
/*-TRACE-*/ $e$,
/*-TRACE-*/ $$ ),
TERM = statement( STATEMENT ),
call( TERM ),
frame_op( $get slot value$,
STATEMENT,
description,
DESCRIPTION ),
frame_op( $index frame into database$,
DESCRIPTION ,
TERM ) ,
fail.
setup_statements :- !.
find_statement( DESCRIPTION, STATEMENT ) :-
frame_op( $retrieve or create indexed frame$,
DESCRIPTION,
statement( [ description: DESCRIPTION ] ) ,
STATEMENT ) .
find_rule( CONCLUSION, TERM ) :-
/*-TRACE-*/ trace_message( find_rule / 1 ,
/*-TRACE-*/ $e, CONCLUSION = $,
/*-TRACE-*/ CONCLUSION ),
frame_op( $get slot values$,
CONCLUSION,
[ description : DESCRIPTION ]),
/*-TRACE-*/ trace_message( find_rule / 1 ,
/*-TRACE-*/ $...DESCRIPTION = $,
/*-TRACE-*/ DESCRIPTION ),
frame_op( $retrieve indexed frame$,
DESCRIPTION ,
rule( _ ) ,
TERM )
/*-TRACE-*/ ,trace_message( find_rule / 1 ,
/*-TRACE-*/ $x, TERM = $,
/*-TRACE-*/ TERM )
.
is_ground_statement( STATEMENT ) :-
frame_op( $has slot$,
STATEMENT ,
description ).
yes_no_ask( QUESTION , ANSWER ) :-
repeat,
log_write( QUESTION ),
log_write( $?$ ),
log_nl,
INSTRUCTIONS =
$ ( y = yes, n = no, d = don't know ) : $,
log_write( INSTRUCTIONS ),
get0_noecho( C ) ,
log_put( C ) ,
log_nl,
(
( C == `y
;
C == `Y
),
ANSWER = yes,
!
;
( C == `N
;
C == `n
),
ANSWER = no ,
!
;
( C == `D
;
C == `d
),
! ,
ANSWER = dont_know
;
log_write($Please answer with an y, n or d.$),
log_nl,
fail
).
report( GOAL ) :-
is_ground_statement( GOAL ) ,
frame_op( $get slot values$,
GOAL ,
[ description : QUESTION ,
value : ANSWER ] ) ,
write( QUESTION ),
write($ = $ ),
write( ANSWER ),
nl.
%%%%%%%%%%%%%%% eof %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%